home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 2 / adb / a-stwifi < prev    next >
Text File  |  1996-02-12  |  18KB  |  627 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --               A D A . S T R I N G S . W I D E _ F I X E D                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.13 $                             --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36.  
  37. with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
  38. with Ada.Strings.Wide_Search;
  39.  
  40. package body Ada.Strings.Wide_Fixed is
  41.  
  42.    ------------------------
  43.    -- Search Subprograms --
  44.    ------------------------
  45.  
  46.    function Index
  47.      (Source  : in Wide_String;
  48.       Pattern : in Wide_String;
  49.       Going   : in Direction := Forward;
  50.       Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
  51.       return    Natural
  52.    renames Ada.Strings.Wide_Search.Index;
  53.  
  54.    function Index
  55.      (Source  : in Wide_String;
  56.       Pattern : in Wide_String;
  57.       Going   : in Direction := Forward;
  58.       Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
  59.       return    Natural
  60.    renames Ada.Strings.Wide_Search.Index;
  61.  
  62.    function Index
  63.      (Source : in Wide_String;
  64.       Set    : in Wide_Maps.Wide_Character_Set;
  65.       Test   : in Membership := Inside;
  66.       Going  : in Direction  := Forward)
  67.       return   Natural
  68.    renames Ada.Strings.Wide_Search.Index;
  69.  
  70.    function Index_Non_Blank
  71.      (Source : in Wide_String;
  72.       Going  : in Direction := Forward)
  73.       return   Natural
  74.    renames Ada.Strings.Wide_Search.Index_Non_Blank;
  75.  
  76.    function Count
  77.      (Source  : in Wide_String;
  78.       Pattern : in Wide_String;
  79.       Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
  80.       return    Natural
  81.    renames Ada.Strings.Wide_Search.Count;
  82.  
  83.    function Count
  84.      (Source   : in Wide_String;
  85.       Pattern  : in Wide_String;
  86.       Mapping  : in Wide_Maps.Wide_Character_Mapping_Function)
  87.       return     Natural
  88.    renames Ada.Strings.Wide_Search.Count;
  89.  
  90.    function Count
  91.      (Source : in Wide_String;
  92.       Set    : in Wide_Maps.Wide_Character_Set)
  93.       return   Natural
  94.    renames Ada.Strings.Wide_Search.Count;
  95.  
  96.    procedure Find_Token
  97.      (Source : in Wide_String;
  98.       Set    : in Wide_Maps.Wide_Character_Set;
  99.       Test   : in Membership;
  100.       First  : out Positive;
  101.       Last   : out Natural)
  102.    renames Ada.Strings.Wide_Search.Find_Token;
  103.  
  104.    ---------
  105.    -- "*" --
  106.    ---------
  107.  
  108.    function "*" (Left  : in Natural;
  109.                  Right : in Wide_Character) return Wide_String
  110.    is
  111.       Result : Wide_String (1 .. Left);
  112.  
  113.    begin
  114.       for J in Result'Range loop
  115.          Result (J) := Right;
  116.       end loop;
  117.  
  118.       return Result;
  119.    end "*";
  120.  
  121.    function "*"
  122.      (Left  : in Natural;
  123.       Right : in Wide_String)
  124.       return  Wide_String
  125.    is
  126.       Result : Wide_String (1 .. Left * Right'Length);
  127.       Ptr    : Integer := 1;
  128.  
  129.    begin
  130.       for J in 1 .. Left loop
  131.          Result (Ptr .. Ptr + Right'Length - 1) := Right;
  132.          Ptr := Ptr + Right'Length;
  133.       end loop;
  134.  
  135.       return Result;
  136.    end "*";
  137.  
  138.    ------------
  139.    -- Delete --
  140.    ------------
  141.  
  142.    function Delete
  143.      (Source  : in Wide_String;
  144.       From    : in Positive;
  145.       Through : in Natural)
  146.       return    Wide_String
  147.    is
  148.    begin
  149.       if From not in Source'Range
  150.         or else Through > Source'Last
  151.       then
  152.          raise Index_Error;
  153.  
  154.       elsif From > Through then
  155.          return Source;
  156.  
  157.       else
  158.          declare
  159.             Result : constant Wide_String :=
  160.                        Source (Source'First .. From - 1) &
  161.                        Source (Through + 1 .. Source'Last);
  162.          begin
  163.             return Result;
  164.          end;
  165.       end if;
  166.    end Delete;
  167.  
  168.    procedure Delete
  169.      (Source  : in out Wide_String;
  170.       From    : in Positive;
  171.       Through : in Natural;
  172.       Justify : in Alignment := Left;
  173.       Pad     : in Wide_Character := Wide_Space)
  174.    is
  175.    begin
  176.       Move (Source  => Delete (Source, From, Through),
  177.             Target  => Source,
  178.             Justify => Justify,
  179.             Pad     => Pad);
  180.    end Delete;
  181.  
  182.    ----------
  183.    -- Head --
  184.    ----------
  185.  
  186.    function Head
  187.      (Source : in Wide_String;
  188.       Count  : in Natural;
  189.       Pad    : in Wide_Character := Wide_Space)
  190.       return   Wide_String
  191.    is
  192.       Result : Wide_String (1 .. Count);
  193.  
  194.    begin
  195.       if Count <= Source'Length then
  196.          Result := Source (Source'First .. Source'First + Count - 1);
  197.  
  198.       else
  199.          Result (1 .. Source'Length) := Source;
  200.  
  201.          for J in Source'Length + 1 .. Count loop
  202.             Result (J) := Pad;
  203.          end loop;
  204.  
  205.       end if;
  206.  
  207.       return Result;
  208.    end Head;
  209.  
  210.    ------------
  211.    -- Insert --
  212.    ------------
  213.  
  214.    function Insert
  215.      (Source   : in Wide_String;
  216.       Before   : in Positive;
  217.       New_Item : in Wide_String)
  218.       return     Wide_String
  219.    is
  220.       Result : Wide_String (1 .. Source'Length + New_Item'Length);
  221.  
  222.    begin
  223.       if Before < Source'First or else Before > Source'Last + 1 then
  224.          raise Index_Error;
  225.       end if;
  226.  
  227.       Result := Source (Source'First .. Before - 1) & New_Item &
  228.                 Source (Before .. Source'Last);
  229.       return Result;
  230.    end Insert;
  231.  
  232.    procedure Insert
  233.      (Source   : in out Wide_String;
  234.       Before   : in Positive;
  235.       New_Item : in Wide_String;
  236.       Drop     : in Truncation := Error)
  237.    is
  238.    begin
  239.       Move (Source => Insert (Source, Before, New_Item),
  240.             Target => Source,
  241.             Drop   => Drop);
  242.    end Insert;
  243.  
  244.    ----------
  245.    -- Move --
  246.    ----------
  247.  
  248.    procedure Move
  249.      (Source  : in  Wide_String;
  250.       Target  : out Wide_String;
  251.       Drop    : in  Truncation := Error;
  252.       Justify : in  Alignment  := Left;
  253.       Pad     : in  Wide_Character  := Wide_Space)
  254.    is
  255.       Sfirst  : constant Integer := Source'First;
  256.       Slast   : constant Integer := Source'Last;
  257.       Slength : constant Integer := Source'Length;
  258.  
  259.       Tfirst  : constant Integer := Target'First;
  260.       Tlast   : constant Integer := Target'Last;
  261.       Tlength : constant Integer := Target'Length;
  262.  
  263.       function Is_Padding (Item : Wide_String) return Boolean;
  264.       --  Determinbe if all characters in Item are pad characters
  265.  
  266.       function Is_Padding (Item : Wide_String) return Boolean is
  267.       begin
  268.          for J in Item'Range loop
  269.             if Item (J) /= Pad then
  270.                return False;
  271.             end if;
  272.          end loop;
  273.  
  274.          return True;
  275.       end Is_Padding;
  276.  
  277.    --  Start of processing for Move
  278.  
  279.    begin
  280.       if Slength = Tlength then
  281.          Target := Source;
  282.  
  283.       elsif Slength > Tlength then
  284.  
  285.          case Drop is
  286.             when Left =>
  287.                Target := Source (Slast - Tlength + 1 .. Slast);
  288.  
  289.             when Right =>
  290.                Target := Source (Sfirst .. Sfirst + Tlength - 1);
  291.  
  292.             when Error =>
  293.                case Justify is
  294.                   when Left =>
  295.                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
  296.                         Target :=
  297.                           Source (Sfirst .. Sfirst + Target'Length - 1);
  298.                      else
  299.                         raise Length_Error;
  300.                      end if;
  301.  
  302.                   when Right =>
  303.                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
  304.                         Target := Source (Slast - Tlength + 1 .. Slast);
  305.                      else
  306.                         raise Length_Error;
  307.                      end if;
  308.  
  309.                   when Center =>
  310.                      raise Length_Error;
  311.                end case;
  312.  
  313.          end case;
  314.  
  315.       --  Source'Length < Target'Length
  316.  
  317.       else
  318.          case Justify is
  319.             when Left =>
  320.                Target (Tfirst .. Tfirst + Slength - 1) := Source;
  321.  
  322.                for J in Tfirst + Slength .. Tlast loop
  323.                   Target (J) := Pad;
  324.                end loop;
  325.  
  326.             when Right =>
  327.                for J in Tfirst .. Tlast - Slength loop
  328.                   Target (J) := Pad;
  329.                end loop;
  330.  
  331.                Target (Tlast - Slength + 1 .. Tlast) := Source;
  332.  
  333.             when Center =>
  334.                declare
  335.                   Front_Pad   : constant Integer := (Tlength - Slength) / 2;
  336.                   Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
  337.  
  338.                begin
  339.                   for J in Tfirst .. Tfirst_Fpad - 1 loop
  340.                      Target (J) := Pad;
  341.                   end loop;
  342.  
  343.                   Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
  344.  
  345.                   for J in Tfirst_Fpad + Slength .. Tlast loop
  346.                      Target (J) := Pad;
  347.                   end loop;
  348.                end;
  349.          end case;
  350.       end if;
  351.    end Move;
  352.  
  353.    ---------------
  354.    -- Overwrite --
  355.    ---------------
  356.  
  357.    function Overwrite
  358.      (Source   : in Wide_String;
  359.       Position : in Positive;
  360.       New_Item : in Wide_String)
  361.       return     Wide_String
  362.    is
  363.    begin
  364.       if Position not in Source'First .. Source'Last + 1 then
  365.          raise Index_Error;
  366.       else
  367.          declare
  368.             Result_Length : Natural :=
  369.                 Natural'Max (Source'Length,
  370.                              Position - Source'First + New_Item'Length);
  371.             Result : Wide_String (1 .. Result_Length);
  372.  
  373.          begin
  374.             Result := Source (Source'First .. Position - 1) & New_Item &
  375.                      Source (Position + New_Item'Length .. Source'Last);
  376.             return Result;
  377.          end;
  378.       end if;
  379.    end Overwrite;
  380.  
  381.    procedure Overwrite
  382.      (Source   : in out Wide_String;
  383.       Position : in Positive;
  384.       New_Item : in Wide_String;
  385.       Drop     : in Truncation := Right)
  386.    is
  387.    begin
  388.       Move (Source => Overwrite (Source, Position, New_Item),
  389.             Target => Source,
  390.             Drop   => Drop);
  391.    end Overwrite;
  392.  
  393.    -------------------
  394.    -- Replace_Slice --
  395.    -------------------
  396.  
  397.    function Replace_Slice
  398.      (Source   : in Wide_String;
  399.       Low      : in Positive;
  400.       High     : in Natural;
  401.       By       : in Wide_String)
  402.       return     Wide_String
  403.    is
  404.       Result_Length : Natural;
  405.  
  406.    begin
  407.       if Low > Source'Last + 1 or else High < Source'First - 1 then
  408.          raise Index_Error;
  409.       else
  410.          Result_Length :=
  411.            Source'Length - Natural'Max (High - Low + 1, 0) + By'Length;
  412.  
  413.          declare
  414.             Result : Wide_String (1 .. Result_Length);
  415.  
  416.          begin
  417.             if High >= Low then
  418.                Result :=
  419.                   Source (Source'First .. Low - 1) & By &
  420.                   Source (High + 1 .. Source'Last);
  421.             else
  422.                Result := Source (Source'First .. Low - 1) & By &
  423.                          Source (Low .. Source'Last);
  424.             end if;
  425.             return Result;
  426.          end;
  427.       end if;
  428.    end Replace_Slice;
  429.  
  430.    procedure Replace_Slice
  431.      (Source   : in out Wide_String;
  432.       Low      : in Positive;
  433.       High     : in Natural;
  434.       By       : in Wide_String;
  435.       Drop     : in Truncation := Error;
  436.       Justify  : in Alignment  := Left;
  437.       Pad      : in Wide_Character  := Wide_Space)
  438.    is
  439.    begin
  440.       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
  441.    end Replace_Slice;
  442.  
  443.    ----------
  444.    -- Tail --
  445.    ----------
  446.  
  447.    function Tail
  448.      (Source : in Wide_String;
  449.       Count  : in Natural;
  450.       Pad    : in Wide_Character := Wide_Space)
  451.       return   Wide_String
  452.    is
  453.       Result : Wide_String (1 .. Count);
  454.  
  455.    begin
  456.       if Count < Source'Length then
  457.          Result := Source (Source'Last - Count + 1 .. Source'Last);
  458.  
  459.       --  Pad on left
  460.  
  461.       else
  462.          for J in 1 .. Count - Source'Length loop
  463.             Result (J) := Pad;
  464.          end loop;
  465.  
  466.          Result (Count - Source'Length + 1 .. Count) := Source;
  467.       end if;
  468.  
  469.       return Result;
  470.    end Tail;
  471.  
  472.    ---------------
  473.    -- Translate --
  474.    ---------------
  475.  
  476.    function Translate
  477.      (Source  : in Wide_String;
  478.       Mapping : in Wide_Maps.Wide_Character_Mapping)
  479.       return    Wide_String
  480.    is
  481.       Result : Wide_String (1 .. Source'Length);
  482.  
  483.    begin
  484.       for J in Source'Range loop
  485.          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
  486.       end loop;
  487.  
  488.       return Result;
  489.    end Translate;
  490.  
  491.    procedure Translate
  492.      (Source  : in out Wide_String;
  493.       Mapping : in Wide_Maps.Wide_Character_Mapping)
  494.    is
  495.    begin
  496.       for J in Source'Range loop
  497.          Source (J) := Value (Mapping, Source (J));
  498.       end loop;
  499.    end Translate;
  500.  
  501.    function Translate
  502.      (Source  : in Wide_String;
  503.       Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
  504.       return    Wide_String
  505.    is
  506.       Result : Wide_String (1 .. Source'Length);
  507.  
  508.    begin
  509.       for J in Source'Range loop
  510.          Result (J - (Source'First - 1)) := Mapping (Source (J));
  511.       end loop;
  512.  
  513.       return Result;
  514.    end Translate;
  515.  
  516.    procedure Translate
  517.      (Source  : in out Wide_String;
  518.       Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
  519.    is
  520.    begin
  521.       for J in Source'Range loop
  522.          Source (J) := Mapping (Source (J));
  523.       end loop;
  524.    end Translate;
  525.  
  526.    ----------
  527.    -- Trim --
  528.    ----------
  529.  
  530.    function Trim
  531.      (Source : in Wide_String;
  532.       Side   : in Trim_End)
  533.       return   Wide_String
  534.    is
  535.       Low  : Natural := Source'First;
  536.       High : Natural := Source'Last;
  537.  
  538.    begin
  539.       if Side = Left or else Side = Both then
  540.          while Low <= High and then Source (Low) = Wide_Space loop
  541.             Low := Low + 1;
  542.          end loop;
  543.       end if;
  544.  
  545.       if Side = Right or else Side = Both then
  546.          while High >= Low and then Source (High) = Wide_Space loop
  547.             High := High - 1;
  548.          end loop;
  549.       end if;
  550.  
  551.       --  All blanks case
  552.  
  553.       if Low > High then
  554.          return "";
  555.  
  556.       --  At least one non-blank
  557.  
  558.       else
  559.          declare
  560.             Result : Wide_String (1 .. High - Low + 1) := Source (Low .. High);
  561.  
  562.          begin
  563.             return Result;
  564.          end;
  565.       end if;
  566.    end Trim;
  567.  
  568.    procedure Trim
  569.      (Source  : in out Wide_String;
  570.       Side    : in Trim_End;
  571.       Justify : in Alignment      := Left;
  572.       Pad     : in Wide_Character := Wide_Space)
  573.    is
  574.    begin
  575.       Move (Source  => Trim (Source, Side),
  576.             Target  => Source,
  577.             Justify => Justify,
  578.             Pad     => Pad);
  579.    end Trim;
  580.  
  581.    function Trim
  582.       (Source : in Wide_String;
  583.        Left   : in Wide_Maps.Wide_Character_Set;
  584.        Right  : in Wide_Maps.Wide_Character_Set)
  585.        return   Wide_String
  586.    is
  587.       Low  : Natural := Source'First;
  588.       High : Natural := Source'Last;
  589.  
  590.    begin
  591.       while Low <= High and then Is_In (Source (Low), Left) loop
  592.          Low := Low + 1;
  593.       end loop;
  594.  
  595.       while High >= Low and then Is_In (Source (High), Right) loop
  596.          High := High + 1;
  597.       end loop;
  598.  
  599.       --  Case where source comprises only characters in the sets
  600.  
  601.       if Low > High then
  602.          return "";
  603.       else
  604.          declare
  605.             Result : Wide_String (1 .. High - Low + 1) := Source (Low .. High);
  606.          begin
  607.             return Result;
  608.          end;
  609.       end if;
  610.    end Trim;
  611.  
  612.    procedure Trim
  613.       (Source  : in out Wide_String;
  614.        Left    : in Wide_Maps.Wide_Character_Set;
  615.        Right   : in Wide_Maps.Wide_Character_Set;
  616.        Justify : in Alignment      := Strings.Left;
  617.        Pad     : in Wide_Character := Wide_Space)
  618.    is
  619.    begin
  620.       Move (Source  => Trim (Source, Left, Right),
  621.             Target  => Source,
  622.             Justify => Justify,
  623.             Pad     => Pad);
  624.    end Trim;
  625.  
  626. end Ada.Strings.Wide_Fixed;
  627.